home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / config.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  5.7 KB  |  158 lines  |  [TEXT/gamI]
  1. ; Type tags
  2.  
  3. (##define-macro (type-fixnum)          0)
  4. (##define-macro (type-special)         7)
  5. (##define-macro (type-pair)            4)
  6. (##define-macro (type-weak-pair)       1)
  7. (##define-macro (type-placeholder)     5)
  8. (##define-macro (type-subtyped)        3)
  9. (##define-macro (type-procedure)       2)
  10.  
  11. ; Subtype tags
  12.  
  13. (##define-macro (subtype-vector)       0)
  14. (##define-macro (subtype-symbol)       1)
  15. (##define-macro (subtype-port)         2)
  16. (##define-macro (subtype-ratnum)       3)
  17. (##define-macro (subtype-cpxnum)       4)
  18. (##define-macro (subtype-frame)        5)
  19. (##define-macro (subtype-task)         6)
  20. (##define-macro (subtype-queue)        7)
  21. (##define-macro (subtype-semaphore)    8)
  22. (##define-macro (subtype-string)       16)
  23. (##define-macro (subtype-bignum)       17)
  24. (##define-macro (subtype-flonum)       18)
  25. (##define-macro (subtype-ovector? x)   `(##fixnum.< ,x 16))
  26.  
  27. ; Miscellaneous
  28.  
  29. (##define-macro (type-range)       8)
  30. (##define-macro (subtype-range)   32)
  31. (##define-macro (char-range)     256)
  32. (##define-macro (char-up-to-down) 32)
  33. (##define-macro (char-whitespace c) `(##char<=? ,c #\space))
  34.  
  35. ; Special objects
  36.  
  37. (##define-macro (data-undef)     -3)
  38. (##define-macro (data-unass)     -4)
  39. (##define-macro (data-unbound)   -5)
  40. (##define-macro (data-eof)       -6)
  41.  
  42. ; Bignum related constants
  43.  
  44. (##define-macro (max-fixnum)        268435455)
  45. (##define-macro (min-fixnum)       -268435456)
  46. (##define-macro (radix)                 16384) ; must be <= sqrt(max fixnum)+1
  47. (##define-macro (radix-width)              14)
  48. (##define-macro (radix-minus-1)         16383)
  49. (##define-macro (minus-radix)          -16384)
  50. (##define-macro (min-fixnum-div-radix) -16384) ; truncate( min fixnum / radix )
  51. (##define-macro (max-digits-for-fixnum)     3) ; bignum if > this many digits
  52.  
  53. (##define-macro (radix-log-den)      32)
  54. (##define-macro (r.2)                16384)
  55. (##define-macro (r-log-rad.2)        14)
  56. (##define-macro (radix-log-r-num.2)  32)
  57. (##define-macro (r.8)                4096)
  58. (##define-macro (r-log-rad.8)        4)
  59. (##define-macro (radix-log-r-num.8)  38)
  60. (##define-macro (r.10)               10000)
  61. (##define-macro (r-log-rad.10)       4)
  62. (##define-macro (radix-log-r-num.10) 34)
  63. (##define-macro (r.16)               4096)
  64. (##define-macro (r-log-rad.16)       3)
  65. (##define-macro (radix-log-r-num.16) 38)
  66.  
  67. ; Flonum related constants
  68.  
  69. (##define-macro (flonum-m-bits)         52)
  70. (##define-macro (flonum-e-bits)         11)
  71. (##define-macro (flonum-sign-bit)       #x8000000000000000) ; (expt 2 (+ (flonum-e-bits) (flonum-m-bits)))
  72. (##define-macro (flonum-m-min)          4503599627370496.0) ; (expt 2.0 (flonum-m-bits))
  73. (##define-macro (flonum-+m-min)         4503599627370496)   ; (expt 2 (flonum-m-bits))
  74. (##define-macro (flonum--m-min)         -4503599627370496)  ; (- (flonum-+m-min))
  75. (##define-macro (flonum-e-bias)         1023) ; (- (expt 2 (- (flonum-e-bits) 1)) 1)
  76. (##define-macro (flonum-e-bias-plus-1)  1024) ; (+ (flonum-e-bias) 1)
  77. (##define-macro (flonum-e-bias-minus-1) 1022) ; (- (flonum-e-bias) 1)
  78. (##define-macro (flonum-max-digits)     17)
  79.  
  80. (##define-macro (inexact-radix)   16384.0) ; (exact->inexact (radix))
  81.  
  82. ; Dispatch for number representation
  83.  
  84. (##define-macro (number-dispatch num err fix big rat flo cpx)
  85.   `(cond ((##fixnum? ,num)                           ,fix)
  86.          ((##subtyped? ,num)
  87.           (let ((##s (##subtype ,num)))
  88.             (cond ((##fixnum.= ##s (subtype-flonum)) ,flo)
  89.                   ((##fixnum.= ##s (subtype-bignum)) ,big)
  90.                   ((##fixnum.= ##s (subtype-ratnum)) ,rat)
  91.                   ((##fixnum.= ##s (subtype-cpxnum)) ,cpx)
  92.                   (else                              ,err))))
  93.          (else                                       ,err)))
  94.  
  95. ; System procedure classes
  96.  
  97. (##define-macro (define-system form . exprs)
  98.  
  99.   (define inlinable-procs '(
  100.  
  101. ##TYPE ##TYPE-CAST ##SUBTYPE ##SUBTYPE-SET!
  102. ##NOT ##NULL? ##UNASSIGNED? ##UNBOUND? ##EQ?
  103. ##FIXNUM? ##SPECIAL? ##PAIR? ##WEAK-PAIR? ##SUBTYPED? ##PROCEDURE? ##PLACEHOLDER?
  104. ##VECTOR? ##SYMBOL? ##PORT? ##RATNUM? ##CPXNUM?
  105. ##STRING? ##BIGNUM? ##FLONUM?
  106. ##CHAR?
  107. ##FIXNUM.+ ##FIXNUM.- ##FIXNUM.*
  108. ##FIXNUM.QUOTIENT ##FIXNUM.REMAINDER ##FIXNUM.MODULO
  109. ##FIXNUM.LOGIOR ##FIXNUM.LOGXOR ##FIXNUM.LOGAND ##FIXNUM.LOGNOT
  110. ##FIXNUM.ASH ##FIXNUM.LSH ##FIXNUM.ZERO? ##FIXNUM.POSITIVE? ##FIXNUM.NEGATIVE?
  111. ##FIXNUM.ODD? ##FIXNUM.EVEN?
  112. ##FIXNUM.= ##FIXNUM.< ##FIXNUM.> ##FIXNUM.<= ##FIXNUM.>=
  113. ##FLONUM.->FIXNUM ##FLONUM.<-FIXNUM
  114. ##FLONUM.+ ##FLONUM.- ##FLONUM.*  ##FLONUM./
  115. ##FLONUM.ABS ##FLONUM.TRUNCATE ##FLONUM.ROUND ##FLONUM.EXP ##FLONUM.LOG
  116. ##FLONUM.SIN ##FLONUM.COS ##FLONUM.TAN
  117. ##FLONUM.ASIN ##FLONUM.ACOS ##FLONUM.ATAN
  118. ##FLONUM.SQRT
  119. ##FLONUM.ZERO? ##FLONUM.POSITIVE? ##FLONUM.NEGATIVE?
  120. ##FLONUM.= ##FLONUM.< ##FLONUM.> ##FLONUM.<= ##FLONUM.>=
  121. ##CHAR=? ##CHAR<? ##CHAR>? ##CHAR<=? ##CHAR>=?
  122. ##CONS ##SET-CAR! ##SET-CDR! ##CAR ##CDR
  123. ##CAAR ##CADR ##CDAR ##CDDR
  124. ##CAAAR ##CAADR ##CADAR ##CADDR ##CDAAR ##CDADR ##CDDAR ##CDDDR
  125. ##CAAAAR ##CAAADR ##CAADAR ##CAADDR ##CADAAR ##CADADR ##CADDAR ##CADDDR
  126. ##CDAAAR ##CDAADR ##CDADAR ##CDADDR ##CDDAAR ##CDDADR ##CDDDAR ##CDDDDR
  127. ##WEAK-CONS ##WEAK-SET-CAR! ##WEAK-SET-CDR! ##WEAK-CAR ##WEAK-CDR
  128. ##MAKE-CELL ##CELL-REF ##CELL-SET!
  129. ##VECTOR-LENGTH ##VECTOR-REF ##VECTOR-SET! ##VECTOR-SHRINK!
  130. ##STRING-LENGTH ##STRING-REF ##STRING-SET! ##STRING-SHRINK!
  131. ##VECTOR8-LENGTH ##VECTOR8-REF ##VECTOR8-SET! ##VECTOR8-SHRINK!
  132. ##VECTOR16-LENGTH ##VECTOR16-REF ##VECTOR16-SET! ##VECTOR16-SHRINK!
  133. ##SLOT-REF ##SLOT-SET!
  134. ##PSTATE
  135. ##TOUCH
  136.  
  137. ))
  138.  
  139.   (define kernel-procs '(
  140.  
  141. ##MAKE-VECTOR
  142. ##MAKE-STRING
  143. ##MAKE-VECTOR16
  144. ##APPLY
  145. ##CALL-WITH-CURRENT-CONTINUATION
  146. ##GLOBAL-VAR
  147. ##GLOBAL-VAR-REF
  148. ##GLOBAL-VAR-SET!
  149.  
  150. ))
  151.  
  152.   (if (memq (car form) kernel-procs)
  153.     `(BEGIN)
  154.     (if (and (memq (car form) inlinable-procs)
  155.              (list? (cdr form)))
  156.       `(DEFINE ,form ,form)
  157.       `(DEFINE ,form ,@exprs))))
  158.